(in-package #:cl-fast-ecs/tests)


(define-test systems
  :parent cl-fast-ecs)

(defparameter *system-run-p* nil)

(defsystem test
  (:components-ro (coordinate))
  (setf *system-run-p* :run))

(define-test "system not being run w/out the components"
  :parent systems
  (make-storage)
  (make-entity)
  (setf *system-run-p* nil)
  (run-systems)
  (false *system-run-p*))

(define-test "system being run with the components"
  :parent systems
  (make-storage)
  (let ((entity (make-entity)))
    (make-coordinate entity :x 0.0 :y 0.0)
    (run-systems)
    (is eq :run *system-run-p*)))

(defparameter *entities* nil)

(define-test system-called-with-correct-entites
  :parent systems
  :depends-on (new-component-definition)
  (with-fixtures '(ecs::*system-registry*)
    (eval
     '(defsystem test3
       (:components-ro (coordinate velocity))
       (push entity *entities*)))
    (make-storage)
    (let* ((entity1 (make-entity))
           (entity2 (make-entity)))
      (setf *entities* nil)
      (run-systems)
      (is equal nil *entities*)

      (make-coordinate entity1)
      (make-velocity entity1 :x 1.0)
      (setf *entities* nil)
      (run-systems)
      (is equal (list entity1) *entities*)

      (make-coordinate entity2)
      (setf *entities* nil)
      (run-systems)
      (is equal (list entity1) *entities*)

      (make-velocity entity2 :x 2.0)
      (setf *entities* nil)
      (run-systems)
      (is equal (list entity2 entity1) *entities*)
      
      (delete-coordinate entity1)
      (setf *entities* nil)
      (run-systems)
      (is equal (list entity2) *entities*)

      (delete-velocity entity2)
      (setf *entities* nil)
      (run-systems)
      (is equal nil *entities*))))

(defparameter *x-value* nil)
(defparameter *y-value* nil)

(define-system test2
  (:components-ro (coordinate))
  (setf *x-value* coordinate-x
        *y-value* coordinate-y))

(define-test "component values passed correctly to the system"
  :parent systems
  (make-storage)
  (let ((entity (make-entity))
        (x0 42.1)
        (y0 42.2))
    (make-coordinate entity :x x0 :y y0)
    (run-systems)
    (is = x0 *x-value*)
    (is = y0 *y-value*)))

(define-test "component values correctly overwritten by the system"
  :parent systems
  (with-fixtures '(ecs::*system-registry*)
    (make-storage)
    (let ((entity (make-entity))
          (x 42.1)
          (y 42.2))
      (declare (special x y))
      (make-coordinate entity)
      (eval
       '(defsystem test6
         (:components-rw (coordinate))
         (setf coordinate-x x
          coordinate-y y)))
      (run-systems)
      (is = x (coordinate-x entity))
      (is = y (coordinate-y entity)))))

(define-test "read-only component values are not overwritten in system"
  :parent systems
  (with-fixtures '(ecs::*system-registry*)
    (make-storage)
    (let* ((entity (make-entity))
           (x 42.1)
           (y 42.2))
      (make-coordinate entity)
      (eval
       `(defsystem test6
         (:components-ro (coordinate))
         (setf coordinate-x ,x
          coordinate-y ,y)))
      (fail (run-systems))
      (is = 0.0 (coordinate-x entity))
      (is = 0.0 (coordinate-y entity)))))

(define-test system-components-no
  :parent systems
  :depends-on (new-component-definition)
  (with-fixtures '(ecs::*system-registry*)
    (make-storage)
    (let ((entity0 (make-object '((:coordinate) (:velocity :x 1.0))))
          (entity1 (make-object '((:coordinate) (:velocity :x 2.0))))
          (entity2 (make-object '((:coordinate))))
          (entity3 (make-object nil))
          (entity4 (make-object '((:velocity)))))
      (declare (ignorable entity0 entity1 entity2 entity3 entity4))
      (eval
       '(defsystem test7
         (:components-ro (coordinate)
          :components-no (velocity))
         (false (has-velocity-p entity))))
      (run-systems)
      (make-velocity entity2 :x 3.0)
      (run-systems))))

(define-test system-redefinition
  :parent systems
  :depends-on ("system being run with the components")
  (eval
   '(defsystem test
     (:components-ro (coordinate)
      :after (test11))
     (setf *system-run-p* :redefined)))
  (make-storage)
  (let ((entity (make-entity)))
    (make-coordinate entity :x 0.0 :y 0.0)
    (run-systems)
    (is eq :redefined *system-run-p*)))

(define-test system-runs-after-redefinition
  :parent systems
  :depends-on (system-redefinition)
  (make-storage)
  (let ((entity (make-entity)))
    (make-coordinate entity :x 0.0 :y 0.0)
    (run-systems)
    (eval
     '(defsystem test
       (:components-ro (coordinate)
        :after (test11))
       (setf *system-run-p* :redefined-again)))
    (run-systems)
    (is eq :redefined-again *system-run-p*)))

#+(or sbcl)
(define-test system-no-hairy-vectors
  :parent systems
  (with-fixtures '(ecs::*system-registry*)
    (let* ((system (eval '(defsystem test4
                           (:components-rw (coordinate))
                           (incf coordinate-x)
                           (incf coordinate-y))))
           (disassembly (let ((*standard-output* (make-string-output-stream)))
                          (disassemble system)
                          (get-output-stream-string *standard-output*))))
      (false (search #+sbcl "HAIRY" disassembly)))))

(define-test system-returns-nil
  :parent systems
  (let ((system (eval '(defsystem test5
                        (:components-ro (coordinate))
                        (1+ coordinate-x)))))
    (make-storage)
    (is eq nil (funcall system))))

(define-test "run-systems returns nil"
  :parent systems
  (make-storage)
  (is eq nil (run-systems)))

(define-test empty-system
  :parent systems
  (finish (eval
           '(defsystem test6
             (:components-ro (coordinate)))))
  (fail (eval
         '(defsystem test6
           ()))))

(define-test nonexistent-components-in-system
  :parent systems
  (fail (eval '(defsystem test6
                (:components-ro (rawr))))))

#-(or allegro ecl)
(define-test defsystem-docstring
  :parent systems
  (let ((system (eval
                 '(defsystem test6
                   (:components-ro (coordinate))
                   "does stuff"
                   (print entity)))))
    (is string= "does stuff" (documentation system 'function))))

(define-test "make-component in a system does not break other systems"
  :parent systems
  :depends-on (new-component-definition)
  (with-fixtures '(ecs::*system-registry*)
    (make-storage)
    (let ((entity0 (make-object '((:coordinate) (:velocity :x 1.0))))
          (entity1 (make-object '((:coordinate) (:velocity :x 2.0))))
          (entity2 (make-object '((:coordinate))))
          (first-run-p t)
          (entities-visited '()))
      (declare (special first-run-p entities-visited entity2)
               (ignore entity0 entity1))
      (defparameter vel-x 3.0)
      (eval
       '(defsystem test7
         (:components-ro (coordinate))
         (unless first-run-p
           (make-velocity entity2 :x (incf vel-x)))))
      (eval
       '(defsystem test8
         (:components-ro (coordinate velocity))
         (unless first-run-p
           (push entity entities-visited))))
      (run-systems)
      (setf first-run-p nil)
      (run-systems)
      (run-systems)
      (is equal '(2 1 0 1 0) entities-visited))))

#-ecs-release
(define-test "defcomponent during run-systems"
  :parent systems
  (with-fixtures '(ecs::*system-registry*
                   ecs::*component-registry* ecs::*component-registry-length*)
    (make-storage)
    (let* ((entity (make-object '((:coordinate)))))
      (declare (ignore entity))
      (eval
       '(defsystem test-defcomponent
         (:components-ro (coordinate))
         (eval
          '(defcomponent friction
            (k 0.0 :type single-float)))))
      (finish (run-systems))))
  #+clisp (setf ecs::*component-registry* (cddr ecs::*component-registry*)))

(defparameter *arguments* nil)

(defsystem arguments
  (:components-ro (coordinate)
   :arguments ((:a fixnum) (:b single-float)))
  (setf *arguments* (list a b)))

(define-test parameter-passing
  :parent systems
  (make-storage)
  (let ((entity (make-entity))
         (a 42)
         (b 3.14))
    (make-coordinate entity)
    (run-systems)
    (is equal (list nil nil) *arguments*)
    (run-systems :a a :b b)
    (is equal (list a b) *arguments*)))

(defparameter *pre-post* nil)

(defsystem pre-post
  (:components-ro (coordinate)
   :initially (push 1 *pre-post*)
   :finally (push 3 *pre-post*))
  (push 2 *pre-post*))

(define-test pre-and-post-forms
  :parent systems
  (make-storage)
  (let ((entity (make-entity)))
    (make-coordinate entity)
    (setf *pre-post* nil)
    (run-systems)
    (is equal '(3 2 1) *pre-post*)
    (setf *pre-post* nil)
    (is equal nil (funcall (system-ref :pre-post)))
    (is equal '(3 2 1) *pre-post*)))

(defparameter *when-cond* nil)
(defparameter *when-run* nil)

(defsystem when-cond
  (:components-ro (coordinate)
   :when *when-cond*)
  (setf *when-run* t))

(define-test when-form
  :parent systems
  (make-storage)
  (make-object `((:coordinate)))
  (setf *when-cond* nil
        *when-run* nil)
  (run-systems)
  (false *when-run*)

  (setf *when-cond* t)
  (run-systems)
  (true *when-run*))

(defparameter *enable-cond* nil)
(defparameter *enable-run* nil)

(defsystem enable-form
  (:components-ro (coordinate)
   :enable *enable-cond*)
  (setf *enable-run* t))

(define-test enable-form
  :parent systems
  (make-storage)
  (make-object `((:coordinate)))
  (setf *enable-cond* nil
        *enable-run* nil)
  (run-systems)
  (false *enable-run*)

  (setf *enable-cond* t)
  (run-systems)
  (true *enable-run*))

(define-test with-form
  :parent systems
  (make-storage)
  (let ((entity (make-object '((:coordinate))))
        (x 1f0)
        (y 2f0))
    (with-fixtures '(ecs::*system-registry*)
      (fail
       (eval
        '(defsystem test9
          (:components-ro (coordinate)
           :with ((a b))))))

      (eval
       `(defsystem test10
          (:components-rw (coordinate)
           :with ((x y) :of-type (single-float single-float) := (values ,x ,y)))
          (setf coordinate-x x
                coordinate-y y)))
      (run-systems)
      (is = x (coordinate-x entity))
      (is = y (coordinate-y entity))

      (eval
       `(defsystem test10
          (:components-rw (coordinate)
           :with (x :of-type single-float := ,y))
          (setf coordinate-x x
                coordinate-y x)))
      (run-systems)
      (is = y (coordinate-x entity))
      (is = y (coordinate-y entity))

      (eval
       `(defsystem test10
          (:components-rw (coordinate)
           :with (x := ,x))
          (setf coordinate-x x
                coordinate-y x)))
      (run-systems)
      (is = x (coordinate-x entity))
      (is = x (coordinate-y entity)))))

(define-test with-form-available-in-enable
  :parent systems
  (make-storage)
  (let ((entity (make-object '((:coordinate))))
        (x 1f0))
    (with-fixtures '(ecs::*system-registry*)
      (eval
       `(defsystem test10
          (:components-rw (coordinate)
           :enable x
           :with (x := ,x))
          (setf coordinate-x x)))
      (run-systems)
      (is = x (coordinate-x entity)))))

(defparameter *delete-component-p* nil)

(defsystem test11
  (:components-ro (coordinate))
  (when *delete-component-p*
    (delete-coordinate entity))
  (setf *system-run-p* t))

(define-test "make component and then instantly delete component"
  :parent systems
  (make-storage)
  (let ((entity (make-entity)))
    (run-systems)
    (setf *delete-component-p* t)
    (make-coordinate entity)
    (run-systems)
    (setf *delete-component-p* nil
          *system-run-p* nil)
    (run-systems)
    (false *system-run-p*)))

(define-test component-deletion-in-system
  :parent systems
  (make-storage)
  (let ((entity1 (make-object '((:coordinate))))
        (entity2 (make-object '((:coordinate))))
        (delete-entity-p nil))
    (declare (special entity1 entity2 delete-entity-p))
    (with-fixtures '(ecs::*system-registry*)
      (eval
       '(defsystem test13
         (:components-ro (coordinate))
         (true (has-coordinate-p entity))))
      (eval
       '(defsystem test12
         (:components-ro (coordinate))
         (when (and delete-entity-p
                    (= entity entity2))
           (delete-entity entity))))
      (run-systems)
      (setf delete-entity-p t)
      (run-systems)
      (setf delete-entity-p nil))))

(define-test component-deletion-before-system
  :parent systems
  (make-storage)
  (with-fixtures '(ecs::*system-registry*)
    (eval
     '(defsystem test-del
       (:components-ro (coordinate))
       (true (has-coordinate-p entity))
       (when (evenp entity)
         (delete-coordinate entity))))
    (let* ((entity1 (make-object `((:coordinate))))
           (entity2 (make-object `((:coordinate))))
           (entity2 (make-object `((:coordinate)))))
      (declare (ignorable entity1 entity2))
      (delete-coordinate entity2)
      (run-systems)
      (run-systems))))

(define-test system-exists
  :parent systems
  (false (system-ref "test16"))
  (eval
   '(defsystem test16
     (:components-ro (coordinate))))
  (true (system-ref "TEST16"))
  (true (system-ref 'test16))
  (true (system-ref :test16))
  (false (system-ref :test17)))

(define-test delete-unknown-system
  :parent systems
  (fail (delete-system (gensym))))

(define-test delete-system-deletes
  :parent systems
  (make-storage)
  (defparameter system-run nil)
  (eval
   '(defsystem test14
     (:components-ro (coordinate))
     (setf system-run t)))
  (make-object `((:coordinate)))
  (delete-system :test14)
  (run-systems)
  (false system-run))

(define-test delete-system-deletes-rebuilder
  :parent systems
  (eval
   '(defsystem test15
     (:components-ro (coordinate))
     (setf system-run t)))
  (delete-system :test15)
  (false (gethash :test15 ecs::*system-bitmap-rebuilders*)))

(define-test system-order
  :parent systems
  (make-storage)
  (defparameter *order* nil)
  (eval
   '(defsystem test18
     (:components-ro (coordinate))
     (push 2 *order*)))
  (eval
   '(defsystem test19
     (:components-ro (coordinate)
      :before (test18))
     (push 1 *order*)))
  (eval
   '(defsystem test20
     (:components-ro (coordinate)
      :after (test18))
     (push 3 *order*)))

  (is eq :test19 (first ecs::*system-registry*))
  (is eq :test18 (third ecs::*system-registry*))
  (is eq :test20 (fifth ecs::*system-registry*))

  (make-object '((:coordinate)))
  (run-systems)
  (is equalp '(3 2 1) *order*))

(define-test system-order-with-no-explicit-constraints
  :parent systems
  (eval
   '(defsystem test24
     (:components-ro (coordinate))))
  (eval
   '(defsystem test25
     (:components-ro (coordinate))))

  (is eq :test25 (first ecs::*system-registry*))
  (is eq :test24 (third ecs::*system-registry*)))

(define-test system-order-designators
  :parent systems
  (eval
   '(defsystem test21
     (:components-ro (coordinate))))
  (eval
   '(defsystem test22
     (:components-ro (coordinate)
      :before ("TEST21"))))
  (eval
   '(defsystem test23
     (:components-ro (coordinate)
      :after (:test21))))

  (is eq :test22 (first ecs::*system-registry*))
  (is eq :test21 (third ecs::*system-registry*))
  (is eq :test23 (fifth ecs::*system-registry*)))

(define-test system-order-unknown-system
  :parent systems
  (fail
   (eval
    '(defsystem test21
      (:components-ro (coordinate)
       :after (totally-unknown-system))))))

(define-test system-order-cycle
  :parent systems
  (eval
   '(defsystem test-a
     (:components-ro (coordinate))))
  (eval
   '(defsystem test-b
     (:components-ro (coordinate)
      :after (test-a))))
  (fail
   (eval
    '(defsystem test-c
      (:components-ro (coordinate)
       :after (test-b)
       :before (test-a))))))

(define-test system-reorder
  :parent systems
  (eval
   '(defsystem test-bb
     (:components-ro (coordinate))))
  (eval
   '(defsystem test-aa
     (:components-ro (coordinate))))

  (is eq :test-aa (first ecs::*system-registry*))
  (is eq :test-bb (third ecs::*system-registry*))

  (eval
   '(defsystem test-cc
     (:components-ro (coordinate)
      :after (test-bb)
      :before (test-aa))))

  (is eq :test-bb (first ecs::*system-registry*))
  (is eq :test-cc (third ecs::*system-registry*))
  (is eq :test-aa (fifth ecs::*system-registry*)))

(define-test system-order-changed-constraints
  :parent systems
  (eval
   '(defsystem test-bbb
     (:components-ro (coordinate))))
  (eval
   '(defsystem test-aaa
     (:components-ro (coordinate))))

  (is eq :test-aaa (first ecs::*system-registry*))
  (is eq :test-bbb (third ecs::*system-registry*))

  (eval
   '(defsystem test-aaa
     (:components-ro (coordinate)
      :after (test-bbb))))

  (is eq :test-bbb (first ecs::*system-registry*))
  (is eq :test-aaa (third ecs::*system-registry*)))

(define-test load-ordered-systems
  :parent systems
  (with-fixtures '(ecs::*system-registry* ecs::*system-order-constraints*
                   ecs::*component-registry* ecs::*component-registry-length*)
    (finish
     (compile-file #P"tests/test-systems-order.lisp" :verbose nil))
    (finish
     (load #P"tests/test-systems-order")))
  #+clisp (setf ecs::*component-registry*
                ;; ¯\_(ツ)_/¯
                (cddr ecs::*component-registry*)))

(define-test allow-symbols-as-arguments
  :parent systems
  (finish
     (handler-case
         (eval
          '(defsystem arguments
            (:components-ro (coordinate)
             :arguments ((a fixnum) (b single-float)))
            (setf *arguments* (list a b))))
       (warning (w)
         (error (format nil "~a" w))))))

(define-test order-correct-after-load
  :parent systems
  :depends-on (component-deletion-in-system
               delete-system-deletes
               component-deletion-before-system
               enable-form
               when-form)
  (with-fixtures '(ecs::*system-registry* ecs::*system-order-constraints*
                   ecs::*component-registry* ecs::*component-registry-length*)
    (uiop:run-program
     (concatenate
      'string
      "echo '(ql:quickload :cl-fast-ecs) (compile-file \"tests/test-systems-load-order.lisp\" :verbose nil)' | "
      #+sbcl "sbcl"
      #+ccl "ccl"
      #+ecl "ecl"
      #+abcl "abcl"
      #+clisp "clisp"
      #+allegro "alisp")
     :force-shell t
     :output *standard-output*)
    (load #P"tests/test-systems-load-order.lisp")
    (is eq :calculate (first ecs::*system-registry*))
    (is eq :draw (third ecs::*system-registry*)))
  #+clisp (setf ecs::*component-registry*
                ;; ¯\_(ツ)_/¯
                (cddr ecs::*component-registry*)))

(define-test with-missing-types
  :parent systems
  (with-fixtures '(ecs::*system-registry*)
    (finish
     (eval
      `(defsystem test26
         (:components-rw (coordinate)
          :with ((x y) :of-type (single-float) := (values 0.0 0.0)))
         (setf coordinate-x x
               coordinate-y y))))))
